home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / genera-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  13.9 KB  |  424 lines
  1. ;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; This is the 3600 version of the file portable-low.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (pushnew ':pcl-internals dbg:*all-invisible-frame-types*)
  33.  
  34. #+IMach                        ;On the I-Machine these are
  35. (eval-when (compile load eval)            ;faster than the versions
  36.                         ;that use :test #'eq.  
  37. (defmacro memq (item list) `(member ,item ,list))
  38. (defmacro assq (item list) `(assoc ,item ,list))
  39. (defmacro rassq (item list) `(rassoc ,item ,list))
  40. (defmacro delq (item list) `(delete ,item ,list))
  41. (defmacro posq (item list) `(position ,item ,list))
  42.  
  43. )
  44.  
  45. compiler::
  46. (defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form)
  47.   (matchp form
  48.     (('cl:the type subform)
  49.      (ignore type)
  50.      subform)
  51.     (* form)))
  52.  
  53. (defmacro %ash (x count)
  54.   (if (and (constantp count) (zerop (eval count)))
  55.       x
  56.       `(the fixnum (ash (the fixnum ,x ) ,count))))
  57.  
  58. ;;;
  59. ;;;
  60. ;;;
  61.  
  62. (defmacro without-interrupts (&body body)
  63.   `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
  64.      (si:inhibit-scheduling-flag t))
  65.      (macrolet ((interrupts-on  ()
  66.           '(when (null outer-scheduling-state)
  67.              (setq si:inhibit-scheduling-flag nil)))
  68.         (interrupts-off ()
  69.           '(setq si:inhibit-scheduling-flag t)))
  70.        (progn outer-scheduling-state)
  71.        ,.body)))
  72.  
  73. ;;;
  74. ;;; It would appear that #, does not work properly in Genera.  At least I can't get it
  75. ;;; to work when I use it inside of std-instance-p (defined later in this file).  So,
  76. ;;; all of this is just to support that.
  77. ;;;
  78. ;;;     WHEN                       EXPANDS-TO
  79. ;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
  80. ;;;   compile to core            '<result of evaluating form>
  81. ;;;   not in compiler at all     (progn <form>)
  82. ;;;
  83. ;;; Believe me when I tell you that I don't know why it is I need both a
  84. ;;; transformer and an optimizer to get this to work.  Believe me when I
  85. ;;; tell you that I don't really care why either.
  86. ;;;
  87. (defmacro load-time-eval (form)
  88.   ;; The interpreted definition of load-time-eval.  This definition
  89.   ;; never gets compiled.
  90.   (let ((value (gensym)))
  91.     `(multiple-value-bind (,value)
  92.      (progn ,form)
  93.        ,value)))
  94.  
  95. (compiler:deftransformer (load-time-eval optimize-load-time-eval) (form)
  96.   (compiler-is-a-loser-internal form))
  97.  
  98. (compiler:defoptimizer (load-time-eval transform-load-time-eval) (form)
  99.   (compiler-is-a-loser-internal form))
  100.  
  101. (defun compiler-is-a-loser-internal (form)  
  102.   ;; When compiling a call to load-time-eval the compiler will call
  103.   ;; this optimizer before the macro expansion.
  104.   (if zl:compiler:(and (boundp '*compile-function*)    ;Probably don't need
  105.                                 ;this boundp check
  106.                                 ;but it can't hurt.
  107.                (funcall *compile-function* :to-core-p))
  108.       ;; Compiling to core.
  109.       ;; Evaluate the form now, and expand into a constant
  110.       ;; (the result of evaluating the form).
  111.       `',(eval (cadr form))
  112.       ;; Compiling to a file.
  113.       ;; Generate the magic which causes the dumper compiler and loader
  114.       ;; to do magic and evaluate the form at load time.
  115.       `',(cons compiler:eval-at-load-time-marker (cadr form))))
  116.  
  117. ;;   
  118. ;;;;;; Memory Block primitives.                ***
  119.   ;;   
  120.  
  121.  
  122. (defmacro make-memory-block (size &optional area)
  123.   `(make-array ,size :area ,area))
  124.  
  125. (defmacro memory-block-ref (block offset)    ;Don't want to go faster yet.
  126.   `(aref ,block ,offset))
  127.  
  128. (defvar class-wrapper-area)
  129. (eval-when (load eval)
  130.   (si:make-area :name 'class-wrapper-area
  131.         :room t
  132.         :gc :static))
  133.  
  134. (eval-when (compile load eval)
  135.   (remprop '%%allocate-instance--class 'inline))
  136.  
  137. (eval-when (compile load eval)
  138.   
  139. (scl:defflavor std-instance
  140.     ((wrapper nil)
  141.      (slots   nil))
  142.     ()
  143.   (:constructor %%allocate-instance--class())
  144.   :ordered-instance-variables)
  145.  
  146. (defvar *std-instance-flavor* (flavor:find-flavor 'std-instance))
  147.  
  148. )
  149.  
  150. #-imach
  151. (scl:defsubst pcl-%instance-flavor (instance)
  152.   (declare (compiler:do-not-record-macroexpansions))
  153.   (sys::%make-pointer sys:dtp-array
  154.               (sys:%p-contents-as-locative
  155.             (sys:follow-structure-forwarding instance))))
  156.  
  157. #+imach
  158. (scl:defsubst pcl-%instance-flavor (instance)
  159.   (sys:%instance-flavor instance))
  160.  
  161. (scl::defsubst std-instance-p (x)
  162.   (and (sys:instancep x)
  163.        (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*))))
  164.  
  165. (scl:defmethod (:print-self std-instance) (stream depth slashify)
  166.   (declare (ignore slashify))
  167.   (print-std-instance scl:self stream depth))
  168.  
  169. (scl:defmethod (:describe std-instance) ()
  170.   (describe-object scl:self *standard-output*))
  171.  
  172. (defmacro %std-instance-wrapper (std-instance)
  173.   `(sys:%instance-ref ,std-instance 1))
  174.  
  175. (defmacro %std-instance-slots (std-instance)
  176.   `(sys:%instance-ref ,std-instance 2))
  177.  
  178. (scl:compile-flavor-methods std-instance)
  179.  
  180.  
  181. (defun printing-random-thing-internal (thing stream)
  182.   (format stream "~\\si:address\\" (si:%pointer thing)))
  183.  
  184. ;;;
  185. ;;; This is hard, I am sweating.
  186. ;;; 
  187. (defun function-arglist (function) (zl:arglist function t))
  188.  
  189. (defun function-pretty-arglist (function) (zl:arglist function))
  190.  
  191.  
  192. ;; New (& complete) fspec handler.
  193. ;;   1. uses a single #'equal htable where stored elements are (fn . plist)
  194. ;;       (maybe we should store the method object instead)
  195. ;;   2. also implements the fspec-plist operators here.
  196. ;;   3. fdefine not only stores the method, but actually does the loading here!
  197. ;;
  198.  
  199. ;;;
  200. ;;;  genera-low.lisp (replaces old method-function-spec-handler)
  201. ;;;
  202.  
  203. ;; New (& complete) fspec handler.
  204. ;;   1. uses a single #'equal htable where stored elements are (fn . plist)
  205. ;;       (maybe we should store the method object instead)
  206. ;;   2. also implements the fspec-plist operators here.
  207. ;;   3. fdefine not only stores the method, but actually does the loading here!
  208. ;;
  209.  
  210. (defvar *method-htable* (make-hash-table :test #'equal :size 500))
  211. (sys:define-function-spec-handler method (op spec &optional arg1 arg2)
  212.   (if (eq op 'sys:validate-function-spec)
  213.       (and (let ((gspec (cadr spec)))
  214.          (or (symbolp gspec)
  215.          (and (listp gspec)
  216.               (eq (car gspec) 'setf)
  217.               (symbolp (cadr gspec))
  218.               (null (cddr gspec)))))
  219.        (let ((tail (cddr spec)))
  220.          (loop (cond ((null tail) (return nil))
  221.              ((listp (car tail)) (return t))
  222.              ((atom (pop tail)))             
  223.              (t (return nil))))))
  224.       (let ((table *method-htable*)
  225.         (key spec))
  226.     (case op
  227.       ((si:fdefinedp si:fdefinition)
  228.        (car (gethash key table nil)))
  229.       (si:fundefine
  230.         (remhash key table))
  231.       (si:fdefine
  232.         (let ((old (gethash key table nil))
  233.           (quals nil)
  234.           (specs nil)
  235.           (ptr (cddr spec)))
  236.           (setq specs
  237.             (loop (cond ((null ptr) (return nil))
  238.                 ((listp (car ptr)) (return (car ptr)))
  239.                 (t (push (pop ptr) quals)))))
  240.           (setf (gethash key table) (cons arg1 (cdr old)))))
  241.       (si:get
  242.         (let ((old (gethash key table nil)))
  243.           (getf (cdr old) arg1)))
  244.       (si:plist
  245.         (let ((old (gethash key table nil)))
  246.           (cdr old)))
  247.       (si:putprop
  248.         (let ((old (gethash key table nil)))
  249.           (unless old
  250.         (setf old (cons nil nil))
  251.         (setf (gethash key table) old))
  252.           (setf (getf (cdr old) arg2) arg1)))
  253.       (si:remprop
  254.         (let ((old (gethash key table nil)))
  255.           (when old
  256.         (remf (cdr old) arg1))))
  257.       (otherwise
  258.         (si:function-spec-default-handler op spec arg1 arg2))))))
  259.  
  260.  
  261. #||
  262. ;; this guy is just a stub to make the fspec handler simpler (and so I could trace it
  263. ;; easier).
  264. (defun pcl-fdefine-helper (gspec qualifiers specializers fn)
  265.   (let* ((dlist (scl:debugging-info fn))
  266.      (class (cadr (assoc 'pcl-method-class dlist)))
  267.      (lambda-list (let ((ll-stuff (assoc 'pcl-lambda-list dlist)))
  268.             (if ll-stuff (cadr ll-stuff) (arglist fn))))
  269.      (doc (cadr (assoc 'pcl-documentation dlist)))
  270.      (plist (cadr (assoc 'pcl-plist dlist))))
  271.     (load-defmethod (or class 'standard-method)
  272.             gspec
  273.             qualifiers
  274.             specializers
  275.             lambda-list
  276.             doc
  277.             (getf plist :isl-cache-symbol)
  278.             plist
  279.             fn)))
  280. ||#
  281.  
  282. ;; define a few special declarations to get pushed onto the function's debug-info
  283. ;; list... note that we do not need to do a (proclaim (declarations ...)) here.
  284. ;;
  285. (eval-when (compile load eval)
  286.   (setf (get 'pcl-plist 'si:debug-info) t)
  287.   (setf (get 'pcl-documentation 'si:debug-info) t)
  288.   (setf (get 'pcl-method-class 'si:debug-info) t)
  289.   (setf (get 'pcl-lambda-list 'si:debug-info) t)
  290. )
  291.  
  292. (eval-when (load eval)
  293.   (setf
  294.     (get 'defmethod      'zwei:definition-function-spec-type) 'defun
  295.     (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun
  296.     (get 'method 'si:definition-type-name) "method"
  297.     (get 'method 'si:definition-type-name) "method"
  298.  
  299.     (get 'declass 'zwei:definition-function-spec-type) 'defclass
  300.     (get 'defclass 'si:definition-type-name) "Class"
  301.     (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1))
  302.   )
  303.  
  304.  
  305.  
  306. (defun (:property defmethod zwei::definition-function-spec-parser) (bp)
  307.   (zwei:parse-pcl-defmethod-for-zwei bp nil))
  308.  
  309. ;;;
  310. ;;; Previously, if a source file in a PCL-based package contained what looks
  311. ;;; like flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form
  312. ;;; appears at top level, and then a flavor-style defmethod form) appear, the
  313. ;;; parser would break.
  314. ;;;
  315. ;;; Now, if we can't parse the defmethod form, we send it to the flavor
  316. ;;; defmethod parser instead.
  317. ;;; 
  318. ;;; Also now supports multi-line arglist sectionizing.
  319. ;;;
  320. zwei:
  321. (defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp)
  322.   (block parser
  323.     (flet ((barf (&optional (error t))
  324.          (return-from parser
  325.            (cond ((eq error :flavor)
  326.               (funcall (get 'flavor:defmethod
  327.                     'zwei::definition-function-spec-parser)
  328.                    bp-after-defmethod))
  329.              (t
  330.               (values nil nil nil error))))))
  331.       (let ((bp-after-generic (forward-sexp bp-after-defmethod))
  332.         (qualifiers ())
  333.         (specializers ())
  334.         (spec nil)
  335.         (ignore1 nil)
  336.         (ignore2 nil))
  337.     (when bp-after-generic
  338.       (multiple-value-bind (generic error-p)
  339.           (read-fspec-item-from-interval bp-after-defmethod
  340.                          bp-after-generic)
  341.         (if error-p
  342.         (barf)                ; error here is really bad.... BARF!
  343.         (progn
  344.           (when (listp generic)
  345.             (if (and (symbolp (car generic))
  346.                  (string-equal (cl:symbol-name (car generic)) "SETF"))
  347.             (setq generic (second generic)    ; is a (setf xxx) form
  348.                   setfp t)
  349.             (barf :flavor)))    ; make a last-ditch-effort with flavor parser
  350.           (let* ((bp1 bp-after-generic)
  351.              (bp2 (forward-sexp bp1)))
  352.               (cl:loop
  353.              (if (null bp2)
  354.                  (barf :more)    ; item not closed - need another line!
  355.                  (multiple-value-bind (item error-p)
  356.                  (read-fspec-item-from-interval bp1 bp2)
  357.                    (cond (error-p (barf))    ;
  358.                      ((listp item)
  359.                       (setq qualifiers (nreverse qualifiers))
  360.                       (cl:multiple-value-setq (ignore1
  361.                                 ignore2
  362.                                 specializers)
  363.                     (pcl::parse-specialized-lambda-list item))
  364.                       (setq spec (pcl::make-method-spec 
  365.                            (if setfp
  366.                                `(cl:setf ,generic)
  367.                                generic)
  368.                            qualifiers
  369.                            specializers))
  370.                       (return (values spec
  371.                               'defun
  372.                               (string-interval
  373.                             bp-after-defmethod
  374.                             bp2))))
  375.                      (t (push item qualifiers)
  376.                     (setq bp1 bp2
  377.                           bp2 (forward-sexp bp2))))))))))))))))
  378.  
  379. zwei:
  380. (progn
  381.   (defun indent-clos-defmethod (ignore bp defmethod-paren &rest ignore)
  382.     (let ((here
  383.         (forward-over *whitespace-chars* (forward-word defmethod-paren))))
  384.       (loop until (char-equal (bp-char here) #\()
  385.         do (setf here
  386.              (forward-over *whitespace-chars* (forward-sexp here))))
  387.       (if (bp-< here bp)
  388.       (values defmethod-paren nil 2)
  389.       (values defmethod-paren nil 4))))
  390.   
  391.   (defindentation (pcl::defmethod . indent-clos-defmethod)))
  392.  
  393. ;;;
  394. ;;; Teach zwei that when it gets the name of a generic function as an argument
  395. ;;; it should edit all the methods of that generic function.  This works for
  396. ;;; ED as well as meta-point.
  397. ;;;
  398. (zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR)
  399.        :around
  400.        setup-function-specs-to-edit-advice
  401.        ()
  402.   (let ((old-definitions (cadddr arglist))
  403.     (new-definitions ())
  404.     (new nil))
  405.     (dolist (old old-definitions)
  406.       (setq new (setup-function-specs-to-edit-advice-1 old))
  407.       (push (or new (list old)) new-definitions))
  408.     (setf (cadddr arglist) (apply #'append (reverse new-definitions)))
  409.     :do-it))
  410.  
  411. (defun setup-function-specs-to-edit-advice-1 (spec)
  412.   (and (or (symbolp spec)
  413.        (and (listp spec) (eq (car spec) 'setf)))
  414.        (gboundp spec)
  415.        (generic-function-p (gdefinition spec))
  416.        (mapcar #'(lambda (m)
  417.            (make-method-spec spec
  418.                      (method-qualifiers m)
  419.                      (unparse-specializers
  420.                        (method-specializers m))))
  421.            (generic-function-methods (gdefinition spec)))))
  422.  
  423.  
  424.